perm filename AEJ.F4[P,LCS] blob
sn#092575 filedate 1974-02-12 generic text, type T, neo UTF8
SUBROUTINE EDGE(X,Y)
C DECEMBER 12, 68
DIMENSION T(0/1770)
REAL A0,A1,A2,A3,A4,A5,A6,A7,
1 COH,B,
2 AF,CL,C2L,CW,D,
3 LEN,L,RO,SL,SW,
4 S2L,RX,RY,HALF,RO2,
5 HEL,RR,RORR,Q,LC,
6 E,EC,ES,ECP,ESP,EX,SQ,SQP
INTEGER COUNT,X,Y
LOGICAL DEBUG
COMMON /EDGEC/ A0,A1,A2,A3,A4,A5,A6,A7,
1 DEBUG,T,
1 HALF,FILE,RR,COH,RX,RY,CL,SL,D,B,FOUND
CALL PROJEC(X,Y)
Q=SQRT(6.*A1**2+2.*(A2**2+A3**2+A4**2+A5**2)+
1 3.*(A6**2+A7**2))
COUNT=-1
L=1.
CL=A2+A4
SL=A3+A5
100 COUNT=COUNT+1
LEN=SQRT(CL**2+SL**2)
CL=CL/LEN
SL=SL/LEN
E=A2*CL+A3*SL
IF(E.GT.0.) GOTO 200
CC IF(E.GT.0.) GOTO 150
CL=-CL
SL=-SL
E=-E
CC150 IF(.NOT.DEBUG) GOTO 200
CC CALL ASD(2,'CL',CL)
CC CALL ASD(2,'SL',SL)
200 C2L=CL**2-SL**2
S2L=2.*SL*CL
EC=A4*CL+A5*SL
EX=A6*C2L+A7*S2L
ES=A1+EX
SQ=SQRT(EC**2+ES**2)
IF(L**2.LT.1.E-3.OR.COUNT.GT.1) GOTO 250
ECP=-A4*SL+A5*CL
ESP=2.*(-A6*S2L+A7*C2L)
SQP=(EC*ECP+ES*ESP)/SQ
L=-(-A2*SL+A3*CL+SQP)/(-E+(-SQP**2+
1 ECP**2+ESP**2-EC**2-4.*ES*EX)/SQ)
HEL=1.-(L**2)/2.
LC=CL
CL=CL*HEL-SL*L
SL=SL*HEL+LC*L
GOTO 100
250 CW=EC/SQ
IF(CW.GE.0.) GOTO 260
COH=0.
D=0.
B=0.
RETURN
260 SW=ES/SQ
CC IF(.NOT.DEBUG) GOTO 300
CC CALL ASD(4,'COUNT',COUNT)
CC CALL ASD(4,'CW',CW)
CC CALL ASD(4,'SW',SW)
300 AF=E+SQ
RO=SW/(1.4142136*(1.+CW))
RO2=RO**2
D=AF*1.30294/((1.-RO2)**2*(1.+2.*RO2))
COH=AF/Q
RORR=RO*RR
RX=FLOAT(X)+0.5-HALF+CL*RORR
RY=FLOAT(Y)+0.5-HALF+SL*RORR
B=A0-D*(4.+RO*(3.+RO*(2.+RO)))*((1.-RO)**2)*0.125
IF(COH.LT.-1.0.OR.1.0.LT.COH) PAUSE 'COH CHECK IN EDGE'
CC400 IF(.NOT.DEBUG) RETURN
CC
CC CALL ASD(3,'COH',COH)
CC CALL ASD(3,'D',D)
CC CALL ASD(3,'B',B)
CC CALL ASD(3,'RX',RX)
CC CALL ASD(3,'RY',RY)
CC CALL ACTES(RO,D,CL,SL)
RETURN
END